Tech Arsenal 1/Tech Arsenal (Arsenal Computer).ISO/tek-02/darc31.zip/DEARCLZW.PAS

Pascal/Delphi Source File | 1993-01-04 | 12KB | 613 lines

(**
 *
 *  Module:       dearclzw.pas
 *  Description:  DEARC Lempel-Ziv-Welch decompression routines
 *                (that is,  unsquashing and uncrunching)
 *
 *  Revision History:
 *    7-26-88: unitized for Turbo v4.0
 *
**)


unit dearclzw;

interface
uses
  dearcabt,
  dearcglb,
  dearcio,
  dearcunp;

procedure init_ucr ( i : integer );
function getc_ucr : integer;
procedure decomp ( SquashFlag : integer );

implementation

(*
 *  definitions for uncrunch / unsquash
 *)
Const
   TABSIZE   = 4096;
   TABSIZEM1 = 4095;
   NO_PRED : word  = $FFFF;
   EMPTY   : word  = $FFFF;

Type
   entry = record
              used         : boolean;
              next         : integer;
              predecessor  : integer;
              follower     : byte
           end;

Var
   stack       : array [0..TABSIZEM1] of byte;
   sp          : integer;
   string_tab  : array [0..TABSIZEM1] of entry;

Var
   code_count : integer;
   code       : integer;
   firstc     : boolean;
   oldcode    : integer;
   finchar    : integer;
   inbuf      : integer;
   outbuf     : integer;
   newhash    : boolean;

(*
 *  definitions for dynamic uncrunch
 *)
Const
  Crunch_BITS = 12;
  Squash_BITS = 13;
  HSIZE = 8192;
  INIT_BITS = 9;
  FIRST = 257;
  CLEAR = 256;
  HSIZEM1 = 8191;
  BITSM1 = 12;

  RMASK : array[0..8] of byte = ($00, $01, $03, $07, $0f, $1f, $3f, $7f, $ff);

Var
  bits,
  n_bits,
  maxcode    : integer;
  prefix     : array[0..HSIZEM1] of integer;
  suffix     : array[0..HSIZEM1] of byte;
  buf        : array[0..BITSM1]  of byte;
  clear_flg  : integer;
  stack1     : array[0..HSIZEM1] of byte;
  free_ent   : integer;
  maxcodemax : integer;
  offset,
  sizex      : integer;


(**
 *
 *  Name:         function h
 *  Description:  calculate hash value for LZW compression
 *                thanks to Bela Lubkin
 *  Parameters:   value -
 *                  pred, foll : integer - pred and follower bytes
 *  Returns:      new hash value
 *
**)
function h(pred, foll : integer) : integer;
{ pbr - removed messy real-to-int stuff - not necessary in TP4 }
var
  Local : longint;
  V     : word;
begin
  if not newhash then
    Local := (pred + foll) or $0800
  else
    Local := (pred + foll) * 15073;

  h := integer(local and $0FFF);
end;


(**
 *
 *  Name:         function eolist
 *  Description:  find end of an LZW chain
 *  Parameters:   value -
 *                  index : integer - start of chain
 *  Returns:      last entry in chain
 *
**)
function eolist(index : integer) : integer;
var temp : integer;
begin
  temp := string_tab[index].next;

  while temp <> 0 do
    begin
      index := temp;
      temp := string_tab[index].next
    end;

  eolist := index
end; (* func eolist *)


(**
 *
 *  Name:         function hash
 *  Description:  add pred/foll pair to LZW hash table
 *  Parameters:   value -
 *                  pred, foll : integer - pair to add
 *  Returns:      new pred val
 *
**)
function hash(pred, foll : integer) : integer;
var
  local     : integer;
    tempnext  : integer;
begin
  local := h(pred, foll);

  if not string_tab[local].used then
    hash := local
  else
    begin
      local := eolist(local);
      tempnext := (local + 101) and $0FFF;

      while string_tab[tempnext].used do
        begin
          tempnext := tempnext + 1;
          if tempnext = TABSIZE then
            tempnext := 0
        end;

      string_tab[local].next := tempnext;
      hash := tempnext
    end
end; (* func hash *)


(**
 *
 *  Name:         procedure upd_tab
 *  Description:  update LZW hash table entry
 *  Parameters:   value -
 *                  pred, foll : integer - pair to update
 *
**)
procedure upd_tab(pred, foll : integer);
begin
  with string_tab[hash(pred, foll)] do
    begin
      used := TRUE;
      next := 0;
      predecessor := pred;
      follower := foll
    end
end; (* proc upd_tab *)


(**
 *
 *  Name:         function gocode : integer
 *
**)
function gocode : integer;
label
  exit;
var
  localbuf  : integer;
  returnval : integer;
begin
  if inbuf = EMPTY then
    begin
      localbuf := getc_unp;

      if localbuf = -1 then
        begin
          gocode := -1;
          goto exit                       (******** was "exit" ************)
        end;

      localbuf := localbuf and $00FF;
      inbuf := getc_unp;
      if inbuf = -1 then
        begin
          gocode := -1;
          goto exit                       (******** was "exit" ************)
        end;

      inbuf := inbuf and $00FF;
      returnval := ((localbuf shl 4) and $0FF0) + ((inbuf shr 4) and $000F);
      inbuf := inbuf and $000F
    end
  else
    begin
      localbuf := getc_unp;
      if localbuf = -1 then
        begin
          gocode := -1;
          goto exit                       (******** was "exit" ************)
        end;

      localbuf := localbuf and $00FF;
      returnval := localbuf + ((inbuf shl 8) and $0F00);
      inbuf := EMPTY
    end;
  gocode := returnval;

exit:

end; (* func gocode *)


(**
 *
 *  Name:         procedure push
 *  Description:  push a char onto LZW 'pending' stack
 *  Parameters:   value -
 *                  c : integer - value to push
 *
**)
procedure push(c : integer);
begin
  stack[sp] := c;
  sp := sp + 1;

  if sp >= TABSIZE then
    abort('Stack overflow')
end; (* proc push *)


(**
 *
 *  Name:         function pop : integer
 *  Description:  pop a character from LZW 'pending' stack
 *  Parameters:   none
 *  Returns:      character popped or EMPTY
 *
**)
function pop : integer;
begin
  if sp > 0 then
    begin
      sp := sp - 1;
      pop := stack[sp]
    end
  else
    pop := EMPTY
end; (* func pop *)


(**
 *
 *  Name:         procedure init_tab
 *  Description:  initialize LZW string table
 *  Parameters:   none
 *
**)
procedure init_tab;
var
  i : integer;
begin
  FillChar(string_tab, sizeof(string_tab), 0);

  for i := 0 to 255 do
    upd_tab(NO_PRED, i);

  inbuf := EMPTY;
end; (* proc init_tab *)


(**
 *
 *  Name:         procedure init_ucr
 *  Description:  init LZW routines
 *  Parameters:   value -
 *                  i : integer - hash seed
 *
**)
procedure init_ucr(i:integer);
begin
  newhash := i = 1;
  sp := 0;
  init_tab;
  code_count := TABSIZE - 256;
  firstc := TRUE
end; (* proc init_ucr *)


(**
 *
 *  Name:         function getc_ucr : integer
 *  Description:  get next (uncompressed) LZW character
 *  Parameters:   none
 *  Returns:      next character
 *
**)
function getc_ucr : integer;
label exit;
var c       : integer;
    code    : integer;
    newcode : integer;
begin
  if firstc then
    begin
      firstc := FALSE;
      oldcode := gocode;
      finchar := string_tab[oldcode].follower;
      getc_ucr := finchar;
      goto exit                         (******** was "exit" ************)
    end;

  if sp = 0 then
    begin
      newcode := gocode;
      code := newcode;
      if code = -1 then
        begin
          getc_ucr := -1;
          goto exit                     (******** was "exit" ************)
        end;

      if not string_tab[code].used then
        begin
          code := oldcode;
          push(finchar)
        end;

      while string_tab[code].predecessor <> NO_PRED do
        with string_tab[code] do
          begin
            push(follower);
            code := predecessor
          end;

      finchar := string_tab[code].follower;
      push(finchar);

      if code_count <> 0 then
        begin
          upd_tab(oldcode, finchar);
          code_count := code_count - 1
        end;

      oldcode := newcode
    end;

  getc_ucr := pop;

exit:

end; (* func getc_ucr *)


(**
 *
 *  Name:         function getcode : integer
 *  Description:
 *  Parameters:   var -
 *
 *                value -
 *
 *  Returns:
 *
**)
function getcode : integer;
label
  next, exit;
var
  code, r_off, bitsx : integer;
  bp : byte;
begin
  if firstch then
    begin
      offset := 0;
      sizex := 0;
      firstch := false;
    end;

  bp := 0;

  if (clear_flg > 0) or (offset >= sizex) or (free_ent > maxcode) then
    begin
      if free_ent > maxcode then
        begin
          n_bits := n_bits + 1;
          if n_bits = BITS then
            maxcode := maxcodemax
          else
            maxcode := (1 shl n_bits) - 1;
        end;

      if clear_flg > 0 then
        begin
          n_bits := INIT_BITS;
          maxcode := (1 shl n_bits) - 1;
          clear_flg := 0;
        end;

      for sizex := 0 to n_bits-1 do
        begin
          code := getc_unp;
          if code = -1 then
            goto next
          else
            buf[sizex] := code;
        end;

      sizex := sizex + 1;

next:

      if sizex <= 0 then
        begin
          getcode := -1;
          goto exit;
        end;

      offset := 0;
      sizex := (sizex shl 3) - (n_bits - 1);
    end;

  r_off := offset;
  bitsx := n_bits;

  (*
   *  get first byte
   *)
  bp := bp + (r_off shr 3);
  r_off := r_off and 7;

  (*
   *  get first part (low order bits)
   *)
  code := buf[bp] shr r_off;
  bp := bp + 1;
  bitsx := bitsx - (8 - r_off);
  r_off := 8 - r_off;

  if bitsx >= 8 then
    begin
      code := code or (buf[bp] shl r_off);
      bp := bp + 1;
      r_off := r_off + 8;
      bitsx := bitsx - 8;
    end;

  code := code or ((buf[bp] and rmask[bitsx]) shl r_off);
  offset := offset + n_bits;
  getcode := code;

exit:

end;


(**
 *
 *  Name:         procedure decomp
 *  Description:  decompress a file with LZW
 *  Parameters:   value -
 *                  SquashFlag : integer - true if Squashing in effect
 *
**)
procedure decomp(SquashFlag : Integer);
label
  next,
  exit;
var
  stackp,
  finchar : integer;
  code,
  oldcode,
  incode : integer;
begin
  if SquashFlag = 0 then
    Bits := crunch_BITS
  else
    Bits := squash_BITS;

  if firstch then
    maxcodemax := 1 shl bits;

  if SquashFlag = 0 then
    begin
      code := getc_unp;
      if code <> BITS then
        begin
           Writeln( 'File packed with ', Code,
                    ' bits, I can only handle ', Bits);
           Halt(1);
        end;
    end;

  clear_flg := 0;
  n_bits := INIT_BITS;
  maxcode := (1 shl n_bits ) - 1;

  for code := 255 downto 0 do
    begin
      prefix[code] := 0;
      suffix[code] := code;
    end;

  free_ent := FIRST;
  oldcode := getcode;
  finchar := oldcode;

  if oldcode = -1 then
    goto exit;

  if SquashFlag = 0 then
    putc_ncr(finchar)
  else
    putc_unp(finchar);

  stackp := 0;

  code := getcode;
  while (code  > -1) do
    begin
      if code = CLEAR then
        begin
          for code := 255 downto 0 do
            prefix[code] := 0;
          clear_flg := 1;
          free_ent := FIRST - 1;
          code := getcode;
          if code = -1 then
            goto next;
        end;
next:
      incode := code;
      if code >= free_ent then
        begin
          stack1[stackp] := finchar;
          stackp := stackp + 1;
          code := oldcode;
        end;

      while (code >= 256) do
        begin
          stack1[stackp] := suffix[code];
          stackp := stackp + 1;
          code := prefix[code];
        end;

      finchar := suffix[code];
      stack1[stackp] := finchar;
      stackp := stackp + 1;
      repeat
        stackp := stackp - 1;
        If SquashFlag = 0 then
          putc_ncr(stack1[stackp])
        else
          putc_unp(stack1[stackp]);
      until stackp <= 0;

      code := free_ent;

      if code < maxcodemax then
        begin
          prefix[code] := oldcode;
          suffix[code] := finchar;
          free_ent := code + 1;
        end;

      oldcode := incode;
      code := getcode;
    end;

exit:

end;

end.